home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / chat2.pl < prev    next >
Encoding:
Perl Script  |  1999-12-28  |  6.5 KB  |  303 lines
  1.  
  2. package chat;
  3.  
  4. require 'sys/socket.ph';
  5.  
  6. if( defined( &main'PF_INET ) ){
  7.     $pf_inet = &main'PF_INET;
  8.     $sock_stream = &main'SOCK_STREAM;
  9.     local($name, $aliases, $proto) = getprotobyname( 'tcp' );
  10.     $tcp_proto = $proto;
  11. }
  12. else {
  13.     $pf_inet = 2;
  14.     $sock_stream = 1;
  15.     $tcp_proto = 6;
  16. }
  17.  
  18.  
  19. $sockaddr = 'S n a4 x8';
  20. chop($thishost = `hostname`);
  21.  
  22. $next = "chatsymbol000000"; # next one
  23. $nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
  24.  
  25.  
  26.  
  27. sub open_port { ## public
  28.     local($server, $port) = @_;
  29.  
  30.     local($serveraddr,$serverproc);
  31.  
  32.     $thisaddr = "\0\0\0\0" ;
  33.     $thisproc = pack($sockaddr, 2, 0, $thisaddr);
  34.  
  35.     *S = ++$next;
  36.     if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
  37.         $serveraddr = pack('C4', $1, $2, $3, $4);
  38.     } else {
  39.         local(@x) = gethostbyname($server);
  40.         return undef unless @x;
  41.         $serveraddr = $x[4];
  42.     }
  43.     $serverproc = pack($sockaddr, 2, $port, $serveraddr);
  44.     unless (socket(S, $pf_inet, $sock_stream, $tcp_proto)) {
  45.         ($!) = ($!, close(S)); # close S while saving $!
  46.         return undef;
  47.     }
  48.     unless (bind(S, $thisproc)) {
  49.         ($!) = ($!, close(S)); # close S while saving $!
  50.         return undef;
  51.     }
  52.     unless (connect(S, $serverproc)) {
  53.         ($!) = ($!, close(S)); # close S while saving $!
  54.         return undef;
  55.     }
  56.     local($fam,$lport);
  57.     ($fam,$lport,$thisaddr) = unpack($sockaddr, getsockname(S));
  58.     $thisproc = pack($sockaddr, 2, 0, $thisaddr);
  59.     select((select(S), $| = 1)[0]);
  60.     $next; # return symbol for switcharound
  61. }
  62.  
  63.  
  64. sub open_listen { ## public
  65.  
  66.     *S = ++$next;
  67.     local($thisport) = shift || 0;
  68.     local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
  69.     local(*NS) = "__" . time;
  70.     unless (socket(NS, $pf_inet, $sock_stream, $tcp_proto)) {
  71.         ($!) = ($!, close(NS));
  72.         return undef;
  73.     }
  74.     unless (bind(NS, $thisproc_local)) {
  75.         ($!) = ($!, close(NS));
  76.         return undef;
  77.     }
  78.     unless (listen(NS, 1)) {
  79.         ($!) = ($!, close(NS));
  80.         return undef;
  81.     }
  82.     select((select(NS), $| = 1)[0]);
  83.     local($family, $port, @myaddr) =
  84.         unpack("S n C C C C x8", getsockname(NS));
  85.     $S{"needs_accept"} = *NS; # so expect will open it
  86.     (@myaddr, $port, $next); # returning this
  87. }
  88.  
  89.  
  90. sub open_proc { ## public
  91.     local(@cmd) = @_;
  92.  
  93.     *S = ++$next;
  94.     local(*TTY) = "__TTY" . time;
  95.     local($pty,$tty) = &_getpty(S,TTY);
  96.     die "Cannot find a new pty" unless defined $pty;
  97.     $pid = fork;
  98.     die "Cannot fork: $!" unless defined $pid;
  99.     unless ($pid) {
  100.         close STDIN; close STDOUT; close STDERR;
  101.         setpgrp(0,$$);
  102.         if (open(DEVTTY, "/dev/tty")) {
  103.             ioctl(DEVTTY,0x20007471,0);        # XXX s/b &TIOCNOTTY
  104.             close DEVTTY;
  105.         }
  106.         open(STDIN,"<&TTY");
  107.         open(STDOUT,">&TTY");
  108.         open(STDERR,">&STDOUT");
  109.         die "Oops" unless fileno(STDERR) == 2;    # sanity
  110.         close(S);
  111.         exec @cmd;
  112.         die "Cannot exec @cmd: $!";
  113.     }
  114.     close(TTY);
  115.     $next; # return symbol for switcharound
  116. }
  117.  
  118.  
  119.  
  120. $nextsubname = "expectloop000000"; # used for subroutines
  121.  
  122. sub expect { ## public
  123.     if ($_[0] =~ /$nextpat/) {
  124.         *S = shift;
  125.     }
  126.     local($endtime) = shift;
  127.  
  128.     local($timeout,$eof) = (1,1);
  129.     local($caller) = caller;
  130.     local($rmask, $nfound, $timeleft, $thisbuf);
  131.     local($cases, $pattern, $action, $subname);
  132.     $endtime += time if $endtime < 600_000_000;
  133.  
  134.     if (defined $S{"needs_accept"}) { # is it a listen socket?
  135.         local(*NS) = $S{"needs_accept"};
  136.         delete $S{"needs_accept"};
  137.         $S{"needs_close"} = *NS;
  138.         unless(accept(S,NS)) {
  139.             ($!) = ($!, close(S), close(NS));
  140.             return undef;
  141.         }
  142.         select((select(S), $| = 1)[0]);
  143.     }
  144.  
  145.  
  146.     unless ($subname = $expect_subname{$caller,@_}) {
  147.         $expect_subname{$caller,@_} = $subname = $nextsubname++;
  148.  
  149.         $cases .= <<"EDQ"; # header is funny to make everything elsif's
  150. sub $subname {
  151.     LOOP: {
  152.         if (0) { ; }
  153. EDQ
  154.         while (@_) {
  155.             ($pattern,$action) = splice(@_,0,2);
  156.             if ($pattern =~ /^eof$/i) {
  157.                 $cases .= <<"EDQ";
  158.         elsif (\$eof) {
  159.              package $caller;
  160.             $action;
  161.         }
  162. EDQ
  163.                 $eof = 0;
  164.             } elsif ($pattern =~ /^timeout$/i) {
  165.             $cases .= <<"EDQ";
  166.         elsif (\$timeout) {
  167.              package $caller;
  168.             $action;
  169.         }
  170. EDQ
  171.                 $timeout = 0;
  172.             } else {
  173.                 $pattern =~ s#/#\\/#g;
  174.             $cases .= <<"EDQ";
  175.         elsif (\$S =~ /$pattern/) {
  176.             \$S = \$';
  177.              package $caller;
  178.             $action;
  179.         }
  180. EDQ
  181.             }
  182.         }
  183.         $cases .= <<"EDQ" if $eof;
  184.         elsif (\$eof) {
  185.             undef;
  186.         }
  187. EDQ
  188.         $cases .= <<"EDQ" if $timeout;
  189.         elsif (\$timeout) {
  190.             undef;
  191.         }
  192. EDQ
  193.         $cases .= <<'ESQ';
  194.         else {
  195.             $rmask = "";
  196.             vec($rmask,fileno(S),1) = 1;
  197.             ($nfound, $rmask) =
  198.                  select($rmask, undef, undef, $endtime - time);
  199.             if ($nfound) {
  200.                 $nread = sysread(S, $thisbuf, 1024);
  201.                 if ($nread > 0) {
  202.                     $S .= $thisbuf;
  203.                 } else {
  204.                     $eof++, redo LOOP; # any error is also eof
  205.                 }
  206.             } else {
  207.                 $timeout++, redo LOOP; # timeout
  208.             }
  209.             redo LOOP;
  210.         }
  211.     }
  212. }
  213. ESQ
  214.         eval $cases; die "$cases:\n$@" if $@;
  215.     }
  216.     $eof = $timeout = 0;
  217.     do $subname();
  218. }
  219.  
  220.  
  221. sub print { ## public
  222.     if ($_[0] =~ /$nextpat/) {
  223.         *S = shift;
  224.     }
  225.     print S @_;
  226.     if( $chat'debug ){
  227.         print STDERR "printed:";
  228.         print STDERR @_;
  229.     }
  230. }
  231.  
  232.  
  233. sub close { ## public
  234.     if ($_[0] =~ /$nextpat/) {
  235.          *S = shift;
  236.     }
  237.     close(S);
  238.     if (defined $S{"needs_close"}) { # is it a listen socket?
  239.         local(*NS) = $S{"needs_close"};
  240.         delete $S{"needs_close"};
  241.         close(NS);
  242.     }
  243. }
  244.  
  245.  
  246. sub select { ## public
  247.     local($timeout) = shift;
  248.     local(@handles) = @_;
  249.     local(%handlename) = ();
  250.     local(%ready) = ();
  251.     local($caller) = caller;
  252.     local($rmask) = "";
  253.     for (@handles) {
  254.         if (/$nextpat/o) { # one of ours... see if ready
  255.             local(*SYM) = $_;
  256.             if (length($SYM)) {
  257.                 $timeout = 0; # we have a winner
  258.                 $ready{$_}++;
  259.             }
  260.             $handlename{fileno($_)} = $_;
  261.         } else {
  262.             $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_;
  263.         }
  264.     }
  265.     for (sort keys %handlename) {
  266.         vec($rmask, $_, 1) = 1;
  267.     }
  268.     select($rmask, undef, undef, $timeout);
  269.     for (sort keys %handlename) {
  270.         $ready{$handlename{$_}}++ if vec($rmask,$_,1);
  271.     }
  272.     sort keys %ready;
  273. }
  274.  
  275.  
  276. sub _getpty { ## private
  277.     local($_PTY,$_TTY) = @_;
  278.     $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
  279.     $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
  280.     local($pty, $tty, $kind);
  281.     if( -e "/dev/pts000" ){        ## mods by Joe Doupnik Dec 1992
  282.         $kind = "pts";        ## SVR4 Streams
  283.     } else {
  284.         $kind = "pty";        ## BSD Clist stuff
  285.     }
  286.     for $bank (112..127) {
  287.         next unless -e sprintf("/dev/$kind%c0", $bank);
  288.         for $unit (48..57) {
  289.             $pty = sprintf("/dev/$kind%c%c", $bank, $unit);
  290.             open($_PTY,"+>$pty") || next;
  291.             select((select($_PTY), $| = 1)[0]);
  292.             ($tty = $pty) =~ s/pty/tty/;
  293.             open($_TTY,"+>$tty") || next;
  294.             select((select($_TTY), $| = 1)[0]);
  295.             system "stty nl>$tty";
  296.             return ($pty,$tty);
  297.         }
  298.     }
  299.     undef;
  300. }
  301.  
  302. 1;
  303.